perm filename CNTRL[P,JRA] blob
sn#193493 filedate 1975-12-23 generic text, type T, neo UTF8
(GLOBAL
(FUNCTIONS /@ EAR NEAR CINTERRUPT VFRAME CPRINT CPRIN1 PROGBIND
RUN STOP NOW PROG COND GO EXIT RETURN DISMISS CEVAL CERR CREAD
CBREAK CERRMESS ASSIGNED? /!/" /!/"1 CIOC
CDEFUN VLOC RVALUE CSET CSETQ TAG ACTBLOCK UNASSIGN ACCESS
CONTROL SAMEFRAME SETACCESS SETCONTROL EXPRESSION CLOSURE FRAME
CALL BACKTRACE LISTEN UP DOWN J CONTINUE ALLOW INVOKE
/: /, /!/> /!/' /!/? /!/; /!/" /!/@ /!/< /!/,)
(RESERVED ← *FRAME CEXPR "OPTIONAL" "REST" "AUX" CURFRAME
* CLAMBDA ↑A *TAG *AU-REVOIR /? /< /> /' /@ /" /$ /; / / /) ))
(DECLARE (SPECIAL ↑Q ↑R ↑W OBARRAY READTABLE ERRLIST *RSET-TRAP) (MACROS T))
(DECLARE
(SPECIAL UARGS BODY EARGS BVARS ALINK CLINK FEXPRP SAVE1
EXP FRAME* FREEVARS FRAMEVARS LEVNUM PC RUNF *TOP TEM
TEM1 TYPE VAL VARS CINTERRUPT STOPLEVEL ALLOW READY NOREC
CHAUXSW GLOBALS IOSW * ** ← INTYPE *K *N *F *L *VAR *FR)
(*FEXPR *EOF* IOPOLL IOSLURP CIOC CDEFUN CERR CBREAK CONNIVER CSETQ /: /@ /, /!")
(*LEXPR MATCH ACCESS CONTROL CSET RVALUE VLOC RUN CPRINT CPRIN1))
(SETQ NOREC T ;FRAME RECLAMATION CONTROL -- SET BY GCCON (IN DB)
INTYPE 'CONNIVER ;WHAT THE CTOP WANTS
IOSW '(NIL NIL NIL)
GLOBALS (NCONC '((NIL NIL) (T T))
(LIST (LIST 'IOSW IOSW))) ;TOP LEVEL BINDINGS
RUNF NIL)
;;;IOSW IS THE LIST OF IOSWITCHES -- (<↑Q> <↑R> <↑W>)
;;;THE FRAME FORMAT IS AS FOLLOWS:
;;; ((IVARS . PC) (BVARS . ALINK) ([FGCMARK] . EXP) . CLINK)
;;; ****IT IS IMPORTANT THAT THE FOLLOWING FREEVARS STAY IN THIS ORDER****
(SETQ FREEVARS '(VAL VARS UARGS BODY EARGS TEM TEM1 ALLOW **)
FRAMEVARS '(FEXPRP FRAME* BVARS ALINK CLINK EXP CINTERRUPT READY))
(DEFUN BVARS MACRO (L) (LIST 'CAADR (CADR L)))
(DEFUN ALINK MACRO (L) (LIST 'CDADR (CADR L)))
(DEFUN EXP MACRO (L)
(LIST 'PROG '(E)
(LIST 'SETQ 'E (LIST 'CADDR (CADR L)))
'(RETURN (COND ((OR (EQ (CAR E) 'MARKED) (EQ (CAR E) 'BVARS-MARKED)) (CDR E))
(T E) ))) )
(DEFUN CLINK MACRO (L) (LIST 'CDDDR (CADR L)))
(DEFUN BODY MACRO (L) '(CADR (ASSQ '*BODY BVARS)))
(DEFUN FGCMARK MACRO (L)
(LIST 'CAADDR (CADR L)) )
(DEFUN PLIST MACRO (L) (LIST 'CDR (CADR L)))
(DEFUN SAVEUP MACRO (L)
'(SETQ
CLINK (MAKEFR RETAG)
EXP EXP1
ALINK (COND ((EQ ALINK1 '*TOP) CLINK) (T ALINK1))
BVARS NIL
FRAME* NIL))
;;;CTOP IS THE CONNIVER TOP-LEVEL
(DEFUN CTOP NIL
((LAMBDA (BASE IBASE READTABLE ↑Q ↑R ↑W *RSET-TRAP RUNF FEXPRP CHAUXSW)
(CATCH
(COND ((EQ INTYPE 'CONNIVER)
(INIT)
(SETQ VAL (RUN1))
(CPRINT (/!" EXIT FROM CONNIVER -- VALUE = (/@ . VAL)))
(SETQ INTYPE 'LISP))
((EQ INTYPE 'LISP)
(SETQ VAL (CBREAK TOP-LEVEL))
(CPRINT (/!" EXIT FROM LISP -- VALUE = (/@ . VAL)))
(SETQ INTYPE 'CONNIVER))
(T (FUNCALL INTYPE)))
CNVR-CATCH))
10.
10.
(GET 'CONNIVREAD 'ARRAY)
NIL
NIL
NIL
'ERROC
NIL
NIL
T))
(DEFUN ERROC (X) (CBREAK CNVR ERROR CATCHER) (THROW 'ERROR CNVR-CATCH))
(DEFUN INIT ()
(COND (RUNF (CERR CONNIVER ALREADY RUNNING) (NEAR)))
(MAPC '(LAMBDA (V) (SET V NIL)) (APPEND FRAMEVARS FREEVARS))
(MAP '(LAMBDA (V) (RPLACA V NIL)) IOSW)
(SETQ PC 'ICEVAL
EXP '(CEVAL '(LISTEN 'TOP-LEVEL))
LEVNUM 0
*TOP '*TOP))
;;;THE HACK REALLY BEGINS HERE -- RUN1 IS THE SYSTEM DRIVER
(DEFUN RUN L
(SETQ VAL (COND ((= L 1) (ARG 1)) (T NIL)))
(RUN1))
(DEFUN RUN1 ()
(COND (RUNF (CERR CONNIVER ALREADY RUNNING--RUN1) (NEAR)) )
(PROG (RUNF ERET)
(SETQ RUNF T)
ERRL (SETQ ERET
(CATCH (PROG ()
LOOP (COND ((AND CINTERRUPT ALLOW)
(SETQ PC (HANDLE)))
((SETQ PC (CAP PC))))
(GO LOOP))
CNVR-CATCH))
(COND ((EQ ERET 'STOP) (RETURN VAL))
((EQ ERET 'ERROR) (NOW '(LISTEN 'ERROR))) )
(GO ERRL)))
;;;(DEFUN CAP (P) (APPLY P ())) ;CAP IS REALLY A LAP HACK
(DEFUN HANDLE ()
(DISPATCH (PROG2 (NOINTERRUPT T)
(CAR CINTERRUPT)
(SETQ CINTERRUPT (CDR CINTERRUPT))
(NOINTERRUPT NIL))
PC
FREEVARS
'*TOP))
(DEFUN STOP N
(PROG ()
(COND ((NOT RUNF) (CERR CONNIVER NOT RUNNING) (RETURN NIL))
((= N 0) (SETQ VAL ()))
((= N 1) (SETQ VAL (ARG 1)))
(T (CERR WRONG # OF ARGS)))
(SETQ PC 'POPJ)
(THROW 'STOP CNVR-CATCH)))
(DEFUN NOW (EXP)
(NOINTERRUPT T)
(NCONC (GET 'CINTERRUPT 'VALUE) (LIST EXP))
(NOINTERRUPT NIL))
(DEFUN CINTERRUPT (EXP)
(NOINTERRUPT T)
(SETQ CINTERRUPT (CONS EXP CINTERRUPT))
(NOINTERRUPT NIL))
(DEFUN ALLOW FEXPR (L) (SETQ ALLOW (CAR L)))
(DECLARE (SPECIAL *L *A))
(DEFUN CERR FEXPR (*L *A)
(PROG (↑Q ↑R ↑W)
(PRINT '**ERROR**)
(ICPRIN1 EXP)
(TERPRI)
(COMP *L *A)
(RETURN (LOOP *A))))
(DEFUN CBREAK FEXPR (*L *A)
(PROG (↑Q ↑R ↑W)
(TERPRI)
(COMP *L *A)
(RETURN (LOOP *A))))
(DEFUN CERRMESS () (COMP *L *A))
(DEFUN COMP (COMMENT ALIST)
(MAPC '(LAMBDA (X)
(ICPRIN1 (COND ((ATOM X) X)
((MEMQ (CAR X) '(/, /@)) (EVAL X ALIST))
(T X)))
(PRINC '/ ))
COMMENT))
(DEFUN LOOP (ALIST)
(PROG (PISTATUS)
(SETQ PISTATUS (NOINTERRUPT NIL) * 'IN-LISP)
LP (ERRSET
(PROGN (ICPRINT *)
(OR ↑Q (PRINC '/
/
/*))
(SETQ ← ** ** (READ (*EOF*)))
(COND ((EQ ** '⎇P)
(AND PISTATUS (NOINTERRUPT T))
(RETURN NIL))
((EQ (CAR **) 'RETURN)
(AND PISTATUS (NOINTERRUPT T))
(RETURN (EVAL (CADR **))))
(T (SETQ * (EVAL **))))))
(GO LP)))
(DEFUN EAR ()
(NOW '(LISTEN 'IN-CONNIVER))
(COND (RUNF (THROW 'EAR CNVR-CATCH)) (T (RUN1)) ))
(DEFUN NEAR ()
(NOW '(GO 'EAR))
(COND (RUNF (THROW 'NEAR CNVR-CATCH)) (T (RUN1)) ))
;;;DISPATCH IS THE "PUSHJ" FOR CONNIVER
(DEFUN DISPATCH (EXP1 RETAG SAVE ALINK1)
(COND ((NUMBERP EXP1) (SETQ VAL EXP1) RETAG)
((ATOM EXP1) (SETQ VAL (IVAL EXP1 ALINK1)) RETAG)
(T (SETQ SAVE1 SAVE) ;SAVE1 USED IN CAP (LAP VERSION)
(PROG (V F)
(SETQ F (CAR EXP1))
BEGIN
(COND ((ATOM F))
((EQ (CAR F) 'CLAMBDA)
(SAVEUP)
(BIND1 '*BODY (CDDR F))
(SETQ VARS (CADR F) UARGS (CDR EXP1))
(RETURN 'ARGB))
((EQ (CAR F) 'LAMBDA)
(SAVEUP)
(SETQ UARGS (CDR EXP1) EARGS (LIST F))
(RETURN 'EVARGS))
((EQ (CAR F) '*CLOSURE)
(SETQ F (CADR F))
(GO BEGIN))
((EQ (CAR F) 'ALLOW)
(SETQ F (CADR F) ALLOW NIL)
(GO BEGIN))
(T (SETQ F (FUNERR F)) (GO BEGIN)))
(SETQ V (PLIST F))
PLP
(COND ((NULL V) (SETQ F (FUNERR F)) (GO BEGIN))
((EQ (CAR V) 'CINT) (SAVEUP) (RETURN (CADR V)))
((EQ (CAR V) 'CEXPR)
(SAVEUP)
(BIND1 '*BODY (CDADR V))
(SETQ VARS (CAADR V) UARGS (CDR EXP1))
(RETURN 'ARGB))
((MEMQ (CAR V) '(FEXPR FSUBR))
((LAMBDA (*TOP FEXPRP) (SETQ VAL (EVAL EXP1))) ALINK1 T)
(RETURN RETAG))
((MEMQ (CAR V) '(EXPR SUBR LSUBR ARRAY))
(SAVEUP)
(SETQ UARGS (CDR EXP1) EARGS (LIST F))
(RETURN 'EVARGS))
((EQ (CAR V) 'AUTOLOAD)
(FUNCALL (STATUS INTERRUPT 18.) (CONS F (CADR V)))
(GO BEGIN))
((EQ (CAR V) 'MACRO)
(RETURN (DISPATCH (FUNCALL (CADR V) EXP1) RETAG SAVE ALINK1))))
(SETQ V (CDR V))
(GO PLP)))))
(DEFUN FUNERR (*F) (CERR UNKNOWN FUNCTION-- (/@ . *F) // FUNCTION <- ?) )
(DEFUN MAKEFR (RETAG1)
(COND ((OR NOREC (NULL FRAME*) (EQ (FGCMARK FRAME*) 'MARKED))
(CONS (CONS (SAVEV) RETAG1)
(CONS (CONS BVARS ALINK)
(CONS EXP CLINK))))
(T
(PROG (INT L)
(SETQ INT (NOINTERRUPT T) L (CAAR FRAME*))
LP (COND (L (SETQ L (PROG2 (RECLAIM1 (CAR L)) ;RECLAIM1 IS A LAP HACK
(CDR L)
(RECLAIM1 L)))
(GO LP)))
(RPLACA (CADR FRAME*) BVARS)
(RPLACD (CADR FRAME*) ALINK)
(RPLACA (CAR FRAME*) (SAVEV))
(RPLACD (CAR FRAME*) RETAG1)
(NOINTERRUPT INT))
FRAME*)))
;;;(DEFUN SAVEV () (MAPCAR '(LAMBDA (V) (CONS V (VALUE V))) SAVE)) ;THIS IS A LAP HACK
;;;(PUTPROP 'VALUE (GET 'EVAL 'LSUBR) 'LSUBR)
;;;FUNCTION CALLS RETURN VIA "POPJ"
(DEFUN POPJ ()
(COND (CLINK
(COND (NOREC (SETQ FRAME* CLINK))
(T (FRECLAIM (PROG2 0. FRAME* (SETQ FRAME* CLINK)))))
(RESTORE))
(T (SETQ PC 'U-LOSE) (THROW 'STOP CNVR-CATCH))))
(DEFUN U-LOSE NIL
(CERR ATTEMPT TO RUN A CONNIVER PROCESS WITH AN UNDEFINED PC)
'U-LOSE)
(DEFUN RESTORE ()
(SETQ
BVARS (BVARS FRAME*)
ALINK (ALINK FRAME*)
EXP (EXP FRAME*)
CLINK (CLINK FRAME*))
(REST1))
;;;(DEFUN REST1 () ;THIS IS A LAP HACK
;;; (MAPC '(LAMBDA (X) (SET (CAR X) (CDR X))) (CAAR FRAME*))
;;; (CDAR FRAME*))
(DEFUN BIND1 (VAR VAL)
(SETQ BVARS (CONS (LIST VAR VAL) BVARS)))
(DEFUN CCLOSE ()
(COND ((ATOM (CAR EXP)))
((EQ (CAAR EXP) '*CLOSURE)
(SETQ ALINK (CADDAR EXP) FRAME* NIL))))
;;;FRAME GARBAGE COLLECTOR
(DEFUN FRECLAIM (FR)
(PROG (MARK INT L)
(COND ((OR (NOT FR) (EQ (SETQ MARK (FGCMARK FR)) 'MARKED))
(RETURN NIL)))
(SETQ INT (NOINTERRUPT T))
;;FIRST FLUSH ((<IVARS> . <PC>) ... )
(SETQ L (CAAR FR))
LP1
(COND (L (SETQ L (PROG2 (RECLAIM1 (CAR L))
(CDR L)
(RECLAIM1 L)))
(GO LP1)))
(RECLAIM1 (CAR FR))
(SETQ FR (PROG2 0 (CDR FR) (RECLAIM1 FR)))
;;NEXT FLUSH ((<BVARS> . <ALINK>) <EXP> . <CLINK>)
(COND ((EQ MARK 'BVARS-MARKED)
(RECLAIM1 (CADR FR)))
(T (DO A (CAAR FR) (CDR A) (NULL A) (RECLAIML (CAR A)))))
(RECLAIML (CAAR FR))
(RECLAIM1 (CAR FR))
(RECLAIM1 (CDR FR))
(RECLAIM1 FR)
(SETQ FR NIL)
(NOINTERRUPT INT)
(RETURN 'T)))
(DEFUN RPLACFGCMARK (FR MARK)
(COND ((MEMQ (FGCMARK FR) '(MARKED BVARS-MARKED))
(RPLACA (CADDR FR) MARK))
(T (RPLACA (CDDR FR) (CONS MARK (CADDR FR)))) ))
(DEFUN MARKFRAME (FR)
(COND ((AND FR (NOT (EQ (FGCMARK FR) 'MARKED)))
(RPLACFGCMARK FR 'MARKED)
(MARKFRAME (ALINK FR))
(MARKFRAME (CLINK FR))) )
FR)
(DEFUN MARKFRAMEB (FR)
(COND ((AND FR (NOT (EQ (FGCMARK FR) 'MARKED)))
(RPLACFGCMARK FR 'BVARS-MARKED)) ))
(DEFUN RECLAIML (L)
(PROG ()
LOOP (COND (L (SETQ L (PROG2 0. (CDR L) (RECLAIM1 L)))
(GO LOOP)) )))
;;;MOBY BINDER -- NORMAL FUNCTION LISTS
(DEFUN ARGB NIL (COND ((NOT (OR VARS UARGS)) (CCLOSE) 'AUXB)
((AND VARS UARGS)
(COND ((ATOM (CAR VARS))
(COND ((EQ (CAR VARS) '"OPTIONAL")
(SETQ VARS (CDR VARS))
(OPTMATCH))
((EQ (CAR VARS) '"REST")
(SETQ VARS (CDR VARS))
(RESTMATCH))
(T (DISPATCH (CAR UARGS)
'ARGB1
'(VARS UARGS)
ALINK))))
((AND (EQ (CAAR VARS) 'QUOTE)
(ATOM (CADAR VARS)))
(ARGQ))
(T (BADECL) (ARGB))))
((AND VARS (OR (EQ (CAR VARS) '"OPTIONAL")
(EQ (CAR VARS) '"REST")))
(CCLOSE)
(FINVAR))
(VARS
(SETQ UARGS (CERR TOO FEW ARGUMENTS--VARS = (/@ . VARS) // ARGS <- ?))
(ARGB))
(UARGS
(SETQ VARS (CERR TOO MANY ARGUMENTS--ARGS = (/@ . UARGS) // VARS <- ?))
(ARGB))))
(DEFUN ARGB1
NIL
(BIND1 (CAR VARS) VAL)
(SETQ VARS (CDR VARS) UARGS (CDR UARGS))
'ARGB)
(DEFUN ARGQ
NIL
(BIND1 (CADAR VARS) (CAR UARGS))
(SETQ VARS (CDR VARS) UARGS (CDR UARGS))
'ARGB)
(DEFUN BADECL ()
(SETQ VARS (CERR BAD DECLARATION--VARS = (/@ . VARS) // VARS <- ?)) )
;;;BIND UP "OPTIONAL"S AND "REST"S
(DEFUN OPTMATCH
NIL
(COND ((NULL UARGS) (CCLOSE) (COND ((NULL VARS) 'AUXB)
(T 'FINVAR)))
((ATOM (CAR VARS)) (COND ((EQ (CAR VARS) '"OPTIONAL")
(SETQ VARS (CDR VARS))
'OPTMATCH)
((EQ (CAR VARS) '"REST")
(SETQ VARS (CDR VARS))
'RESTMATCH)
(T (DISPATCH (CAR UARGS)
'OPTMATCH1
'(VARS UARGS)
ALINK))))
((EQ (CAAR VARS) 'QUOTE)
(COND ((ATOM (CADAR VARS)) (BIND1 (CADAR VARS) (CAR UARGS))
(SETQ VARS (CDR VARS) UARGS (CDR UARGS))
'OPTMATCH)
(T (BADECL) (OPTMATCH))))
((ATOM (CAAR VARS)) (DISPATCH (CAR UARGS)
'OPTMATCH1
'(VARS UARGS)
ALINK))
((AND (EQ (CAAAR VARS) 'QUOTE) (ATOM (CADAAR VARS)))
(BIND1 (CADAAR VARS) (CAR UARGS))
(SETQ VARS (CDR VARS) UARGS (CDR UARGS))
'OPTMATCH)
(T (BADECL) (OPTMATCH))))
(DEFUN OPTMATCH1
NIL
(BIND1 (COND ((ATOM (CAR VARS)) (CAR VARS)) (T (CAAR VARS))) VAL)
(SETQ VARS (CDR VARS) UARGS (CDR UARGS))
'OPTMATCH)
(DEFUN RESTMATCH NIL (COND ((ATOM (CAR VARS)) (SETQ EARGS NIL) (EVREST))
((AND (EQ (CAAR VARS) 'QUOTE)
(ATOM (CADAR VARS)))
(BIND1 (CADAR VARS) UARGS)
(CCLOSE) 'AUXB)
(T (BADECL) (RESTMATCH))))
(DEFUN EVREST NIL (COND ((NULL UARGS)
(BIND1 (CAR VARS) (REVERSE EARGS))
(CCLOSE) 'AUXB)
(T (DISPATCH (CAR UARGS)
'EVREST1
'(VARS UARGS EARGS)
ALINK))))
(DEFUN EVREST1 NIL (SETQ UARGS (CDR UARGS) EARGS (CONS VAL EARGS)) 'EVREST)
;;;WHEN RUN OUT OF ARGS BUT HAVE SOME "OPTIONAL"S OR "REST"S
(DEFUN FINVAR ()
(COND ((NULL VARS) 'AUXB)
((ATOM (CAR VARS))
(COND ((EQ (CAR VARS) '"OPTIONAL") (SETQ VARS (CDR VARS))
'FINVAR)
((EQ (CAR VARS) '"REST")
(SETQ VARS (CDR VARS))
(COND ((ATOM (CAR VARS)) (BIND1 (CAR VARS) NIL) 'AUXB)
((AND (EQ (CAAR VARS) 'QUOTE)
(ATOM (CADAR VARS)))
(BIND1 (CADAR VARS) NIL)
'AUXB)
(T (BADECL) (FINVAR))))
(T (BIND1 (CAR VARS) '*UNASSIGNED)
(SETQ VARS (CDR VARS))
'FINVAR)))
((EQ (CAAR VARS) 'QUOTE)
(COND ((ATOM (CADAR VARS))
(BIND1 (CADAR VARS) '*UNASSIGNED)
(SETQ VARS (CDR VARS))
'FINVAR)
(T (BADECL) (FINVAR))))
((ATOM (CAAR VARS))
(DISPATCH (CADAR VARS) 'FINVAR1 '(VARS) '*TOP))
((AND (EQ (CAAAR VARS) 'QUOTE) (ATOM (CADAAR VARS)))
(DISPATCH (CADAR VARS) 'FINVAR2 '(VARS) '*TOP))
(T (BADECL) (FINVAR))))
(DEFUN FINVAR1 NIL (BIND1 (CAAR VARS) VAL) (FINVAR3))
(DEFUN FINVAR2 NIL (BIND1 (CADAAR VARS) VAL) (FINVAR3))
(DEFUN FINVAR3 NIL (SETQ VARS (CDR VARS)) 'FINVAR)
;;;BINDS "AUX" VARIABLES
(DEFUN AUXB ()
(SETQ BODY (BODY))
(COND ((NULL BODY) (POPJ))
((EQ (CAR BODY) '"AUX")
(SETQ VARS (CADR BODY))
'AUXB1)
(T 'LINE)))
(DEFUN AUXB1 NIL (COND ((NULL VARS) (SETQ BODY (CDDR (BODY))) 'LINE)
((ATOM (CAR VARS)) (BIND1 (CAR VARS) '*UNASSIGNED)
(SETQ VARS (CDR VARS))
'AUXB1)
((AND (ATOM (CAAR VARS)) (CDAR VARS))
(DISPATCH (CADAR VARS)
'AUXB2
'(VARS)
'*TOP))
(T (BADECL) (AUXB1))))
(DEFUN AUXB2 NIL (BIND1 (CAAR VARS) VAL) (SETQ VARS (CDR VARS)) 'AUXB1)
(DEFUN CPROG NIL (BIND1 '*BODY (CDR EXP)) 'AUXB)
(DEFUN PROGBIND () (DISPATCH (CADR EXP) 'PROGB1 NIL ALINK))
(DEFUN PROGB1 ()
(BIND1 '*BODY (CONS '"AUX" (CONS (SETQ VARS VAL) (CDDR EXP))))
'AUXB1)
;;;BASIC PROG ITERATION LOOP
(DEFUN LINE ()
(COND ((NULL BODY) (POPJ))
(T (DISPATCH (CAR BODY) 'LINE1 '(BODY) '*TOP))))
(DEFUN LINE1 NIL (SETQ BODY (CDR BODY)) 'LINE)
;;;EVALUATES ARGUMENTS TO LISP EXPRS SUBRS AND LSUBRS
(DEFUN EVARGS ()
(COND ((NULL UARGS)
((LAMBDA (*TOP EARGS1)
(SETQ VAL (APPLY (CAR EARGS1) (CDR EARGS1))))
ALINK
(REVERSE EARGS))
(POPJ))
(T (DISPATCH (CAR UARGS) 'ARGS1 '(UARGS EARGS) ALINK))))
(DEFUN ARGS1 ()
(SETQ UARGS (CDR UARGS) EARGS (CONS VAL EARGS)) 'EVARGS)
;;;LOGICAL FLOW OF CONTROL FUNCTIONS
(DEFUN CCOND () (SETQ UARGS (CDR EXP)) (CONDLP))
(DEFUN CONDLP ()
(COND ((NULL UARGS) (POPJ))
(T (DISPATCH (CAAR UARGS) 'COND1 '(UARGS) '*TOP))))
(DEFUN COND1 NIL (COND (VAL (BIND1 '*BODY (CDAR UARGS)) 'AUXB)
(T (SETQ UARGS (CDR UARGS)) 'CONDLP)))
(DEFUN IAND ()
(COND ((NULL (SETQ EXP (CDR EXP))) (OR VAL (SETQ VAL T)) (POPJ))
((DISPATCH (CAR EXP) 'IAND1 '(EXP) '*TOP)) ))
(DEFUN IAND1 ()
(COND (VAL 'IAND)
(T (POPJ)) ))
(DEFUN IOR ()
(COND ((NULL (SETQ EXP (CDR EXP))) (SETQ VAL NIL) (POPJ))
((DISPATCH (CAR EXP) 'IOR1 '(EXP) '*TOP)) ))
(DEFUN IOR1 ()
(COND (VAL (POPJ))
(T 'IOR) ))
(DEFUN FR (E)
(COND ((EQ (CAR E) '*FRAME) (CADR E))
((EQ (CAR E) '*TAG) (CADDR E))
((EQ (CAR E) '*CLOSURE) (CADDR E))
((EQ (CAR E) '*AU-REVOIR) (CADR E))
(T (FR (CERR BAD FRAME SUPPLIED // FRAME <- ?)))))
(DEFUN FIRSTARG (N *F)
(COND ((< N 1) (CERR TOO FEW ARGUMENTS-- (/@ . *F) // VAR <- ?))
((ARG 1)) ))
(DEFUN GETARGK (*K *N *F)
(PROG2 (AND (> *N *K)
(CERR (/@ - *N *K) TOO MANY ARGUMENTS-- (/@ . *F) // GO ON?))
(ARG *K)) )
;;;USERS OF FRAMES -- FLOW OF CONTROL CONTROLLERS
(DEFUN CGO NIL (DISPATCH (CADR EXP) 'GO1 NIL ALINK))
(DEFUN GO1 ()
(COND ((ATOM VAL)
(PROG (FR B)
(SETQ FR ALINK)
LP (COND ((NULL FR) (RETURN (TAGERR)))
((SETQ B (ASSQ '*BODY (BVARS FR)))
(COND ((SETQ B
(DO L (CADR B) (CDR L) (NULL L)
(COND ((AND (NOT (ATOM (CAR L)))
(EQ (CAAR L) '/:)
(EQ (CADAR L) VAL))
(RETURN L)))))
(SETQ FRAME* FR)
(RESTORE)
(SETQ BODY B)
(RETURN 'LINE)))))
(SETQ FR (CLINK FR))
(GO LP)))
((EQ (CAR VAL) '*TAG)
(SETQ FRAME* (CADDR VAL))
(RESTORE))
(T (TAGERR))))
(DEFUN TAGERR ()
(SETQ VAL (CERR FOLLOWING NOT SEEN AS TAG--(/@ . VAL)--GO // ARG <- ?))
(GO1) )
(DEFUN CEXIT NIL (DISPATCH (CADR EXP) 'EXIT1 () ALINK))
(DEFUN EXIT1 ()
(SETQ TEM VAL)
(COND ((CDDR EXP)
(DISPATCH (CADDR EXP) 'EXIT2 '(TEM) ALINK))
(T (PROG (FR)
(SETQ FR ALINK)
LP (COND ((NULL FR)
(SETQ VAL (CERR NO FRAME WITH BODY--EXIT // FRAME <- ?))
(RETURN (EXIT2)))
((ASSQ '*BODY (BVARS FR))
(SETQ CLINK (CLINK FR))
(RETURN (POPJ))))
(SETQ FR (CLINK FR))
(GO LP)))))
(DEFUN EXIT2 ()
(SETQ CLINK (CLINK (FR VAL)) VAL TEM)
(POPJ))
(DEFUN CRETURN NIL (DISPATCH (CADR EXP) 'RETURN1 NIL ALINK))
(DEFUN RETURN1 NIL (PROG (FR)
(SETQ FR ALINK)
LP (COND ((NULL FR)
(SETQ FR (CERR NO NON-COND FRAME WITH BODY--RETURN // FRAME <- ?)
TEM VAL VAL FR)
(RETURN (EXIT2)))
((AND (ASSQ '*BODY (BVARS FR))
(NOT (EQ (CAR (EXP FR)) 'COND)))
(SETQ CLINK (CLINK FR))
(RETURN (POPJ))))
(SETQ FR (CLINK FR))
(GO LP)))
(DEFUN CDISMISS NIL (COND ((CDR EXP)
(SETQ TEM ())
(DISPATCH (CADR EXP) 'EXIT2 '(TEM) ALINK))
(T (SETQ VAL ()) (RETURN1))))
(DEFUN CONTINUE () (DISPATCH (CADR EXP) 'CONT1 () ALINK))
(DEFUN CONT1 ()
(SETQ TEM VAL)
(COND ((CDDR EXP) (DISPATCH (CADDR EXP) 'CONT2 '(TEM) ALINK))
(T (SETQ VAL () FRAME* (FR TEM)) (RESTORE))))
(DEFUN CONT2 () (SETQ FRAME* (FR TEM)) (RESTORE))
;;;RELATIVE EVALUATORS
(DEFUN ICEVAL NIL (DISPATCH (CADR EXP) 'CEVAL1 () ALINK))
(DEFUN CEVAL1 ()
(SETQ TEM1 VAL)
(COND ((CDDR EXP)
(DISPATCH (CADDR EXP) 'CEVAL2 '(TEM1) ALINK))
(T (SETQ VAL (FRAME)) 'CEVAL2)))
(DEFUN CEVAL2 ()
(DISPATCH TEM1 'POPJ NIL (FR VAL)))
(DEFUN ICALL NIL (DISPATCH (CADR EXP) 'CALL1 NIL ALINK))
(DEFUN CALL1 () (DISPATCH (CONS VAL (CDDR EXP)) 'POPJ NIL ALINK))
(DEFUN INVOKE () (DISPATCH (CADR EXP) 'TRY1 () ALINK))
(DEFUN TRY1 () (SETQ TEM VAL) (DISPATCH (CADDR EXP) 'TRY2 '(TEM) ALINK))
(DEFUN TRY2 ()
(SETQ EXP (LIST TEM VAL) FRAME* NIL)
(PROG (AL METHPAT)
(COND ((NULL (SETQ AL (MATCH (SETQ METHPAT (PATTERN TEM)) VAL)))
(SETQ VAL NIL)
(RETURN (POPJ)))
(T (SETQ BVARS (NCONC (LIST (LIST '*CALLPAT VAL)
(LIST '*METHPAT METHPAT)
(LIST '*CALLALIST (CADR AL))
(LIST '*BODY (TEXT TEM)))
(CAR AL)))
(CCLOSE)
(RETURN 'AUXB)))))
(DEFUN TEXT (METH)
(COND ((ATOM METH) (TEXT (GET METH 'DATUM)))
((EQ (CAR METH) '*CLOSURE) (TEXT (CADR METH)))
(T (CADDDR METH)))) ;;;IDENTIFIER MANIPULATORS
(DEFUN VFRAME N
(PROG (FR LOC VAR BV)
(SETQ VAR (FIRSTARG N 'VFRAME))
(COND ((= N 1) (SETQ FR *TOP))
(T (SETQ FR (FR (GETARGK 2 N 'VFRAME)))) )
LP (SETQ BV (COND ((NULL FR) (RETURN NIL))
((EQ FR '*TOP) BVARS)
(T (BVARS FR)) ))
(COND ((SETQ LOC (ASSQ VAR BV))
(RETURN (LIST '*FRAME (CHAUX FR) LOC))))
(SETQ FR (COND ((EQ FR '*TOP) ALINK) ((ALINK FR)) ))
(GO LP) ))
(DEFUN VLOC N (PROG (FR LOC VAR)
(SETQ VAR (FIRSTARG N 'VLOC))
(SETQ FR (COND ((= N 1.)
(COND ((SETQ LOC (ASSQ (ARG 1)
BVARS))
(MARKFRAMEB (OR FRAME* (SETQ FRAME* (MAKEFR PC))))
(RETURN LOC)))
ALINK)
(T (FR (GETARGK 2 N 'VLOC))) ))
LP (COND ((NULL FR) (RETURN (ASSQ VAR GLOBALS)))
((SETQ LOC (ASSQ VAR (BVARS FR)))
(MARKFRAMEB FR)
(RETURN LOC)))
(SETQ FR (ALINK FR))
(GO LP))) (DEFUN RVALUE N
(PROG (*VAR)
(SETQ *VAR (FIRSTARG N 'RVALUE))
(RETURN
((LAMBDA (LOC)
(COND (LOC (COND ((CDDR LOC) (APPLY (CADDR LOC) (LIST 'RVALUE LOC))))
(CADR LOC))
(T (CSET *VAR (CERR UNBOUND VARIABLE (/@. *VAR)
--RVALUE // VALUE <- ?))) ))
(COND ((= N 1.) (VLOC *VAR))
(T (VLOC *VAR (GETARGK 2 N 'RVALUE))) ))) ))
(DECLARE (SPECIAL ID))
(DEFUN IVAL (ID FR)
(COND
((OR (EQ ID NIL) (EQ ID T)) ID)
(T (PROG (ANS)
(COND ((EQ FR '*TOP)
(COND ((SETQ ANS (ASSQ ID BVARS))
(GO FOUND))
(T (SETQ FR ALINK)))))
LP (COND ((NULL FR)
(COND ((SETQ ANS (ASSQ ID GLOBALS)) (GO FOUND))
(T (RETURN (CSET ID (CERR UNBOUND VARIABLE (/@ . ID) // VAL <- ?))))))
((SETQ ANS (ASSQ ID (BVARS FR))) (GO FOUND)))
(SETQ FR (ALINK FR))
(GO LP)
FOUND
(COND ((CDDR ANS) (APPLY (CADDR ANS) (LIST '/, ANS))))
(COND ((EQ (SETQ ANS (CADR ANS)) '*UNASSIGNED)
(RETURN (CSET ID (CERR UNASSIGNED VARIABLE (/@ . ID) // VAL <- ?)))))
(RETURN ANS)))))
(DECLARE (UNSPECIAL ID))
(DEFUN ICSETQ () (SETQ UARGS EXP) (CSETQ0))
(DEFUN CSETQ0 ()
(COND ((CDR UARGS)
(COND ((AND (ATOM (CADR UARGS)) (CDDR UARGS))
(DISPATCH (CADDR UARGS) 'CSETQ1 '(UARGS) ALINK))
(T (CERR ODD NUMBER OF ARGUMENTS--CSETQ (/@ CDR UARGS) // GO ON?) (POPJ))))
(T (POPJ))))
(DEFUN CSETQ1 ()
((LAMBDA (LOC)
(COND (LOC (COND ((CDDR LOC) (APPLY (CADDR LOC) (LIST 'CSET LOC VAL))))
(RPLACA (CDR LOC) VAL))
(T (SETQ GLOBALS (CONS (LIST (CADR UARGS) VAL) GLOBALS)))))
(VLOC (CADR UARGS)))
(SETQ UARGS (CDDR UARGS))
'CSETQ0)
(DEFUN CSETQ FEXPR (*L)
(PROG (LASVAL)
LOOP (COND (*L
(COND ((CDR *L)
(SETQ LASVAL (CSET (CAR *L) (EVAL (CADR *L))) *L (CDDR *L))
(GO LOOP))
(T (CERR ODD NUMBER OF ARGUMENTS--CSETQ (/@ . *L) // GO ON?)) )) )
(RETURN LASVAL) ))
(DEFUN CSET N
(PROG (NEWVAL)
(RETURN
((LAMBDA (LOC)
(COND (LOC (COND ((CDDR LOC) (APPLY (CADDR LOC) (LIST 'CSET LOC NEWVAL))))
(RPLACA (CDR LOC) NEWVAL))
(T (SETQ GLOBALS (CONS (LIST (ARG 1) NEWVAL) GLOBALS))))
NEWVAL)
(COND ((< N 1)
(CERR NO ARGS--CSET // GO ON?)
(RETURN NIL))
((= N 1)
(SETQ NEWVAL (CERR TOO FEW ARGS--CSET // NEWVAL <- ?))
(VLOC (ARG 1)))
((PROG2 (SETQ NEWVAL (ARG 2)) (= N 2))
(VLOC (ARG 1)))
(T (VLOC (ARG 1) (GETARGK 3 N 'CSET))) ))) ))
(DEFUN UNASSIGN (VAR) (CSET VAR '*UNASSIGNED))
(DEFUN ASSIGNED? (VAR)
(PROG (LOC)
(RETURN (COND ((SETQ LOC (VLOC VAR)) (NOT (EQ (CADR LOC) '*UNASSIGNED))) )) )) ;;;FRAME CONSTRUCTORS
(DEFUN CHAUX (*FR)
(PROG ()
(COND ((EQ *FR '*TOP) (SETQ *FR
(COND (FEXPRP (SETQ FRAME* (MAKEFR PC)))
(T ALINK)))) )
(RETURN
(COND ((NULL *FR) NIL)
((AND CHAUXSW (MEMQ (CDAR *FR) '(AUXB1 FINVAR1 FINVAR2)))
(CHAUX (FR (CERR ATTEMPT TO RETURN INCOMPLETE FRAME
WITH EXP (/@ EXP *FR) // FRAME <- ?))))
(T (MARKFRAME *FR)) )) ))
(DEFUN TAG N
(PROG (FR B BV NAME)
(COND ((= N 1) (SETQ NAME (ARG 1)))
((> N 1) (TMA 'TAG)) )
(SETQ FR *TOP)
LP (SETQ BV (COND ((NULL FR) (RETURN NIL))
((EQ FR '*TOP) BVARS)
((BVARS FR)) ))
(COND ((SETQ B (ASSQ '*BODY BV))
(SETQ B (CADR B))
(COND ((SETQ B (COND ((NOT NAME)
(COND ((EQ (CAR B) '"AUX") (CDDR B))
(B) ))
(T (DO L B (CDR L) (NULL L)
(COND ((AND (NOT (ATOM (CAR L)))
(EQ (CAAR L) '/:)
(EQ (CADAR L) NAME))
(RETURN L))))
) ))
(SETQ FR (CHAUX FR))
(RETURN (LIST '*TAG NAME
(CONS (CONS (LIST (CONS 'BODY B))
'LINE)
(CDR FR))))))))
(SETQ FR (COND ((EQ FR '*TOP) ALINK) ((CLINK FR)) ))
(GO LP) ))
(DEFUN ACTBLOCK () (TAG) )
(DEFUN ACCESS N
(LIST '*FRAME
(CHAUX (COND ((= N 0.) (COND (FEXPRP ALINK) ((ALINK ALINK)) ))
(T (ALINK (FR (GETARGK 1 N 'ACCESS)))) ))) )
(DEFUN CONTROL N
(LIST '*FRAME
(CHAUX (COND ((= N 0.) (COND (FEXPRP CLINK) ((CLINK ALINK)) ))
(T (CLINK (FR (GETARGK 1 N 'CONTROL)))) ))) )
(DEFUN CLOSURE N
(PROG (PROC)
(SETQ PROC (FIRSTARG N 'CLOSURE))
(RETURN (COND ((OR (ATOM PROC) (NOT (EQ (CAR PROC) '*CLOSURE)))
(LIST '*CLOSURE
PROC
(CHAUX (COND ((= N 1) (CURLINK))
(T (FR (GETARGK 2 N 'CLOSURE))) ))))
(PROC) )) ))
(DEFUN FRAME NIL (LIST '*FRAME (CHAUX (CURLINK))))
(DEFUN SAMEFRAME (FR1 FR2)
(EQ (CDDR (FR FR1)) (CDDR (FR FR2))) )
(DEFUN CURLINK () (COND (FEXPRP '*TOP) (T ALINK) ))
;;;VERY DANGEROUS USER (HA!) FUNCTIONS
(DEFUN SETACCESS (T1 S) (RPLACD (CADR (FR T1)) (FR S)) S)
(DEFUN SETCONTROL (T1 S) (RPLACD (CDDR (FR T1)) (FR S)) S)
(DEFUN CEVAL N
((LAMBDA (PC EXP ALINK BVARS *TOP)
(PROG (CLINK FRAME* FEXPRP RUNF) (RETURN (RUN1))))
'CEVAL3
(ARG 1)
(COND ((> N 1) (FR (ARG 2))) (ALINK))
(COND ((> N 1) NIL) (BVARS) )
'*TOP))
(DEFUN CEVAL3 () (DISPATCH EXP 'POPJ (CDR FREEVARS) *TOP) )
;;;USER INTERFACE
(DEFUN CDEFUN FEXPR (L) (PUTPROP (CAR L) (CDR L) 'CEXPR) (CAR L))
(CDEFUN LISTEN (MESSAGE)
"AUX"((EAR (GENLEV)) (IOSW (LIST NIL NIL NIL))
CURFRAME ACC LISTENFRAME DOWNSTACK)
(/: LISTEN)
(ALLOW T)
(CPRINT MESSAGE)
(PROGBIND (LIST EAR 'LOOP)
(CSET EAR (TAG 'EAR))
(CSETQ LOOP (TAG 'LOOP) LISTENFRAME (TAG 'LISTEN)
ACC (CONTROL LISTENFRAME) CURFRAME ACC)
(J)
(/: EAR)
(SETQ * (/, EAR))
(/: LOOP)
(COND ((CIO) (RETURN NIL)))
(SET '* (CEVAL (/@ . **)))
(GO LOOP) ))
(DEFUN CIO FEXPR (L)
(IOSLURP)
(COND ((OR ↑R (NOT ↑W))
(ICPRINT *)
(OR ↑Q (PRINC '/
/
/←))))
(SETQ ← ** ** (READ (*EOF*)))
(IOPOLL)
(EQ ** '⎇P))
(DEFUN *EOF* FEXPR (L) '(*EOF*))
(DEFUN GENLEV NIL (READLIST (APPEND '(E A R -)
(EXPLODE (SETQ LEVNUM (ADD1 LEVNUM))))))
;;;DEBUGGING AIDS
(DEFUN EXPRESSION (F) (EXP (FR F)))
(DEFUN BACKTRACE N (PROG (FR M TEM CHAUXSW IOSW)
(SETQ FR (FRAME) IOSW (/, IOSW) ↑R (CADR IOSW) ↑W (CADDR IOSW))
(COND ((= N 0.) (SETQ M 262143.))
(T (SETQ M (ARG 1.))))
(COND ((= N 2.) (SETQ TEM (ARG 2.))))
(COND ((NOT (= M 0))
(IBT EXP NIL)
(COND (TEM (ICPRIN1 (CONS FREEVARS PC))) )
(SETQ M (1- M))) )
LP (COND ((OR (NULL (CADR FR)) (= M 0.))
(RETURN 'END-OF-BACKTRACE)))
(IBT (EXPRESSION FR) FR)
(COND (TEM (ICPRIN1 (CAADR FR))))
(SETQ FR (COND ((EQ (CAR (EXPRESSION FR)) 'LISTEN) (ACCESS FR))
(T (CONTROL FR)) ))
(SETQ M (/1- M))
(GO LP)))
(DEFUN LISTENB
(FR ARG)
(PRINT (IVAL 'EAR (CADR FR)))
(ICPRIN1 (IVAL 'MESSAGE (CADR FR)))
(PRINC '/ ))
(DEFPROP LISTEN LISTENB BACKTRACE)
(DEFUN CONDB (FR ARG) (PRINT 'COND))
(DEFPROP COND CONDB BACKTRACE)
(DEFUN PROGB (FR ARG) (PRINT 'PROG))
(DEFPROP PROG PROGB BACKTRACE)
(DEFUN CEVALB (FR ARG) (COND (TEM (PRINT 'CEVAL))))
(DEFPROP CEVAL CEVALB BACKTRACE)
(DEFUN PROGBINDB (FR ARG) (PRINT 'PROGBIND))
(DEFPROP PROGBIND PROGBINDB BACKTRACE)
(DEFUN IBT (E FR)
((LAMBDA (B)
(COND (B (APPLY B (LIST FR (CDR E))))
(T (ICPRINT E)) ))
(GET (CAR E) 'BACKTRACE))
NIL)
(CDEFUN UP ("OPTIONAL" (N 1) (WHATTODO 'BT) (WHICHLINK 'CONTROL))
"AUX" ((FR1 CURFRAME) (DSTACK ()) FR2)
(CSETQ WHICHLINK (SAFEFR WHICHLINK))
(/: UPLOOP)
(COND ((= N 0) (CSETQ DOWNSTACK (NCONC DSTACK DOWNSTACK))
(ESTABLISH FR1 WHATTODO))
((FR (CSETQ FR2 (CALL WHICHLINK FR1)))
(CSETQ N (1- N) DSTACK (CONS FR1 DSTACK) FR1 FR2)
(GO 'UPLOOP))
(T (CPRINT (/!/" (/, N) FRAMES TOO FAR))
NIL) ))
(CDEFUN DOWN ("OPTIONAL" (N 1) (WHATTODO 'BT))
"AUX" ((DSTACK DOWNSTACK) (FR1 CURFRAME))
(/: DOWNLOOP)
(COND ((= N 0) (CSETQ DOWNSTACK DSTACK)
(ESTABLISH FR1 WHATTODO))
(DSTACK
(CSETQ N (1- N) FR1 (CAR DSTACK) DSTACK (CDR DSTACK))
(GO 'DOWNLOOP))
(T (CPRINT (/!/" (/, N) FRAMES TOO FAR)) NIL) ))
(CDEFUN J ("OPTIONAL" (FR1 ACC) (WHATTODO 'BT))
(CSETQ DOWNSTACK ())
(ESTABLISH FR1 WHATTODO) )
(DEFUN SAFEFR (*F)
(/!/" LAMBDA (FR)
(PROG (CHAUXSW) (RETURN ((/@ . *F) FR)) )))
(CDEFUN ESTABLISH (FR1 ACTION)
(SETACCESS LISTENFRAME (CSETQ CURFRAME FR1))
(COND ((EQ ACTION 'BT) (BT (EXPRESSION FR1) FR1))
((CEVAL ACTION)) ))
(DEFUN BT (E FR)
(PROG2 (IOSLURP) (IBT E FR) (IOPOLL)))
(DEFUN /: FEXPR (L) L)
(DEFUN /@ FEXPR (\L) (EVAL \L))
(DEFUN /, FEXPR (L) (IVAL (CAR L) *TOP))
(DEFUN ↑A (X)
(PROG (FUN ↑Q ↑R ↑W ASC)
(TYIPEEK 1)
(TYI)
(SETQ ASC (TYI))
(COND ((SETQ FUN (OR (GET (ASCI ASC 'OBARRAY) '↑A)
(GET (ASCI ASC 'CONNIVER) '↑A)))
(FUNCALL FUN ASC))
(T (PRINC '/?)))))
(DEFUN ASCI (N OBARRAYATOM)
((LAMBDA (OBARRAY) (ASCII N)) (GET OBARRAYATOM 'ARRAY)) )
(SSTATUS INTERRUPT 2 '↑A)
(DEFPROP X ↑AX ↑A)
(DEFUN ↑AX (X) (ICPRINT EXP))
(DEFPROP E ↑AE ↑A)
(DEFUN ↑AE (X) (NOW '(LISTEN '↑AE)))
(DEFPROP N ↑AN ↑A)
(DEFUN ↑AN (X) (NOW '(GO 'EAR)))
(DEFPROP L ↑AL ↑A)
(DEFUN ↑AL (X) (CBREAK '↑AL))
;;;CONNIVER I-O STUFF
(DEFUN CREAD N (PROG2 (IOSLURP) (READ) (IOPOLL)))
(DEFUN CPRINT N (PROG2 (IOSLURP) (ICPRINT (ARG 1)) (IOPOLL)))
(DEFUN CPRIN1 N (PROG2 (IOSLURP) (ICPRIN1 (ARG 1)) (IOPOLL)))
(DEFUN ICPRIN1 (X)
(PROG (Y)
(COND ((ATOM X) (PRIN1 X) (RETURN X))
((AND (ATOM (CAR X)) (SETQ Y (GET (CAR X) 'CPRINT)))
(APPLY Y X) (RETURN X)))
(SETQ Y X)
(PRINC '/()
PLOOP
(ICPRIN1 (CAR Y))
(COND ((NULL (SETQ Y (CDR Y))) (PRINC '/)) (RETURN X))
((OR (ATOM Y)
(AND (ATOM (CAR Y)) (GET (CAR Y) 'CPRINT)))
(PRINC '/ /./ )
(ICPRIN1 Y)
(PRINC '/))
(RETURN X)))
(PRINC '/ )
(GO PLOOP)))
(DEFUN ICPRINT (X) (PRINC '/
/
) (ICPRIN1 X) (PRINC '/ ) X)
(DEFUN IOSLURP FEXPR (L)
((LAMBDA (IOSW)
(SETQ ↑R (CADR IOSW) ↑W (CADDR IOSW))
(COND ((CAR IOSW)
(COND (↑Q)
((STATUS UREAD) (SETQ ↑Q T))
(T (RPLACA IOSW NIL))))
(T (SETQ ↑Q NIL))) )
( /, IOSW)))
(DEFUN IOPOLL FEXPR (L) (CSET 'IOSW (LIST ↑Q ↑R ↑W)))
(DEFUN CIOC FEXPR (L) (APPLY 'IOC L) (IOPOLL))
(DEFUN CP-MACR FEXPR (E) (PRINC (CAR E)) (PRIN1 (CADR E)))
(DEFPROP /: CP-MACR CPRINT)
(DEFPROP /, CP-MACR CPRINT)
(DEFUN CP-QUOTE FEXPR (E) (PRINC '/') (ICPRIN1 (CADR E)))
(DEFPROP QUOTE CP-QUOTE CPRINT)
(DEFUN CP-*TAG FEXPR (TAG)
(PRINC '/()
(PRIN1 (CAR TAG))
(PRINC '/ )
(ICPRIN1 (CADR TAG))
(PRINC '/ )
(ICPRIN1 (EXP (CADDR TAG)))
(PRINC '/)))
(DEFPROP *TAG CP-*TAG CPRINT)
(DEFPROP *CLOSURE CP-*TAG CPRINT)
(DEFUN CP-*FRAME FEXPR (FRAME)
(PRINC '/()
(PRIN1 (CAR FRAME))
(PRINC '/ )
(ICPRIN1 (EXP (CADR FRAME)))
(PRINC '/)))
(DEFPROP *FRAME CP-*FRAME CPRINT)
(DEFPROP *AU-REVOIR CP-*FRAME CPRINT)
(DEFUN CP-MATCH FEXPR (E)
(PRINC (CAR E))
(COND ((CDDR E) (ICPRIN1 (CDR E)))
((CADR E) (ICPRIN1 (CADR E)) )))
(DEFPROP /!/> CP-MATCH CPRINT)
(DEFPROP /!/' CP-MATCH CPRINT)
(DEFPROP /!/? CP-MATCH CPRINT)
(DEFPROP /!/; CP-MATCH CPRINT)
(DEFPROP /!/< CP-MATCH CPRINT)
(DEFPROP /!/, CP-MATCH CPRINT)
(DEFPROP /!/@ CP-MATCH CPRINT)
(DEFUN CP-/!/" FEXPR (E) (PRINC (CAR E)) (ICPRIN1 (CDR E)))
(DEFPROP /!/" CP-/!/" CPRINT)
(DEFPROP /@ CP-/!/" CPRINT) (DEFUN COLMAC NIL (LIST '/: (READ)))
(DEFUN COMMAC () (LIST '/, (READ)))
(DEFUN ATMAC () (CONS '/@ (READ)))
(DEFUN EXMAC ()
(PROG (C F)
(SETQ C (NXTCHR))
(COND ((EQ C '/$) (TYI)
(RETURN ((LAMBDA (OBARRAY) (READ))
(GET 'CONNIVER 'ARRAY))))
((SETQ F (ASSQ C '((/" /!/") (/@ /!/@))))
(TYI)
(RETURN (CONS (CADR F) (READ))))
((SETQ F (ASSQ C '((/? /!/?) (/' /!/') (/> /!/>)
(/, /!/,) (/< /!/<) (/; /!/;))))
(TYI)
(SETQ F (CADR F)))
(T (PRINT (LIST 'BAD '/! 'MACRO C)) (IOC G)))
(RETURN (COND ((SEPARATOR (NXTCHR)) (LIST F NIL))
((ATOM (SETQ C (READ))) (LIST F C))
(T (CONS F C))))))
(DEFUN NXTCHR () (ASCII (TYIPEEK)))
(DEFUN SEPARATOR (CHAR) (MEMQ CHAR '(/ / /) )))
(*ARRAY 'CONNIVREAD 'READTABLE)
((LAMBDA (READTABLE)
(SSTATUS MACRO /: 'COLMAC)
(SSTATUS MACRO /, 'COMMAC)
(SSTATUS MACRO /@ 'ATMAC)
(SSTATUS MACRO /! 'EXMAC))
(GET 'CONNIVREAD 'ARRAY))
(DEFUN /!" FEXPR (L) (/!"1 L))
(DEFUN /!"1 (L)
(COND ((ATOM L) L)
((EQ (CAR L) '/@) (EVAL (CDR L)))
((EQ (CAR L) '/,) (IVAL (CADR L) *TOP))
((ATOM (CAR L)) (CONS (CAR L) (/!"1 (CDR L))))
((EQ (CAAR L) '/!/@) (APPEND (EVAL (CDAR L))(/!"1 (CDR L))))
(T (CONS (/!/"1 (CAR L)) (/!"1 (CDR L))))) )
;;;THESE ARE THE CINTS DEFINED IN THIS FILE.
(DEFPROP PROG CPROG CINT)
(DEFPROP PROGBIND PROGBIND CINT)
(DEFPROP COND CCOND CINT)
(DEFPROP AND IAND CINT)
(DEFPROP OR IOR CINT)
(DEFPROP GO CGO CINT)
(DEFPROP EXIT CEXIT CINT)
(DEFPROP RETURN CRETURN CINT)
(DEFPROP DISMISS CDISMISS CINT)
(DEFPROP CONTINUE CONTINUE CINT)
(DEFPROP CEVAL ICEVAL CINT)
(DEFPROP CALL ICALL CINT)
(DEFPROP INVOKE INVOKE CINT)
(DEFPROP CSETQ ICSETQ CINT)
β ββ